home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-tasren.adb < prev    next >
Text File  |  1994-05-19  |  54KB  |  1,596 lines
  1. -----------------------------------------------------------------------------
  2. --                                                                         --
  3. --                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                         --
  5. --            S Y S T E M . T A S K I N G . R E N D E Z V O U S            --
  6. --                                                                         --
  7. --                                 B o d y                                 --
  8. --                                                                         --
  9. --                            $Revision: 1.9 $                             --
  10. --                                                                         --
  11. --          Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                         --
  13. -- GNARL is free software; you can redistribute it and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License as published by the --
  15. -- Free Software Foundation; either version 2,  or (at  your  option)  any --
  16. -- later  version.   GNARL is distributed in the hope that it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. -- MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL; see --
  21. -- file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. -- Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                         --
  24. -----------------------------------------------------------------------------
  25.  
  26. with System.Task_Primitives; use System.Task_Primitives;
  27.  
  28. with System.Tasking.Abortion;
  29. --  Used for Abortion.Defer_Abortion,
  30. --           Abortion.Undefer_Abortion
  31. --           Abortion.Abort_To_Level
  32.  
  33. with System.Tasking.Protected_Objects;
  34. --  Used for Protected_Objects.Check_Exception
  35.  
  36. with System.Error_Reporting;
  37. --  Used for Error_Reporting.Assert
  38.  
  39. --  with System.Tasking.Queuing; use System.Tasking.Queuing;
  40. --  Temporary. (queuing is in Tasking)
  41.  
  42. with System.Tasking.Runtime_Types;
  43. --  Used for Runtime_Types.ATCB_Ptr,
  44. --           Runtime_Types.ATCB_To_ID,
  45. --           Runtime_Types.ID_To_ATCB,
  46. --           Runtime_Types.Null_PO;
  47. --           Runtime_Types."<",
  48. --           Runtime_Types.">=",
  49. --           Runtime_Types."=",
  50. --           Runtime_Types.Task_Stage
  51. --           Runtime_Types.Accepting_State
  52. --           Runtime_Types.Vulnerable_Complete_Activation
  53.  
  54. with System.Compiler_Exceptions;
  55. --  Used for Compiler_Exceptions."="
  56.  
  57. package body System.Tasking.Rendezvous is
  58.  
  59.    function ID_To_ATCB (ID : Task_ID) return Runtime_Types.ATCB_Ptr
  60.      renames Tasking.Runtime_Types.ID_To_ATCB;
  61.  
  62.    function ATCB_To_ID (Ptr : Runtime_Types.ATCB_Ptr) return Task_ID
  63.      renames Runtime_Types.ATCB_To_ID;
  64.  
  65.    procedure Assert (B : Boolean; M : String)
  66.      renames Error_Reporting.Assert;
  67.  
  68.    procedure Defer_Abortion
  69.      renames Abortion.Defer_Abortion;
  70.  
  71.    procedure Undefer_Abortion renames
  72.      Abortion.Undefer_Abortion;
  73.  
  74.    --  Following should be replaced by use type ???
  75.  
  76.    function "<" (L, R : Runtime_Types.Task_Stage) return Boolean
  77.      renames Runtime_Types."<";
  78.  
  79.    function ">=" (L, R : Runtime_Types.Task_Stage) return Boolean
  80.      renames Runtime_Types.">=";
  81.  
  82.    function "=" (L, R : Runtime_Types.Accepting_State) return Boolean
  83.      renames Runtime_Types."=";
  84.  
  85.    function "=" (L, R : Exception_ID)
  86.      return Boolean renames Compiler_Exceptions."=";
  87.  
  88.    type Select_Treatment is (
  89.      Accept_Alternative_Selected,
  90.      Else_Selected,
  91.      Terminate_Selected,
  92.      Accept_Alternative_Open,
  93.      No_Alternative_Open);
  94.  
  95.    Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
  96.      (Simple_Mode         => No_Alternative_Open,
  97.       Else_Mode           => Else_Selected,
  98.       Terminate_Mode      => Terminate_Selected);
  99.  
  100.    -----------------------
  101.    -- Local Subprograms --
  102.    -----------------------
  103.  
  104.    procedure Make_Passive
  105.      (T : Runtime_Types.ATCB_Ptr);
  106.    --  Record that task T is passive.
  107.  
  108.    procedure Boost_Priority
  109.      (Call     : Entry_Call_Link;
  110.       Acceptor : Runtime_Types.ATCB_Ptr);
  111.    pragma Inline (Boost_Priority);
  112.  
  113.    procedure Test_Call
  114.      (Entry_Call           : in out Entry_Call_Link;
  115.       Rendezvous_Completed : out Boolean);
  116.    --  Test if a rendezvous can be made right away. Returns True if the
  117.    --  rendezvous has occurred (and finished).
  118.    --  Problem: Try not to call this when the acceptor is not accepting.
  119.    --  What does problem mean??? advice??? why??? absolute rule???
  120.  
  121.    function Test_Selective_Wait
  122.      (Acceptor     : Runtime_Types.ATCB_Ptr;
  123.       Open_Accepts : Accept_List_Access;
  124.       Select_Mode  : Select_Modes)
  125.       return         Select_Treatment;
  126.    pragma Inline (Test_Selective_Wait);
  127.    --  Test if there is a call waiting on any entry, and whether any selects
  128.    --  are open. Set Acceptor.Chosen_Index to selected alternative if an
  129.    --  accept alternative can be selected.
  130.  
  131.    procedure Universal_Complete_Rendezvous (Ex : Exception_ID);
  132.    pragma Inline (Universal_Complete_Rendezvous);
  133.    --  Called by acceptor to wake up caller and optionally propagate exception
  134.  
  135.    ------------------
  136.    -- Make_Passive --
  137.    ------------------
  138.  
  139.    --  If T is the last dependent of some master in task P to become passive,
  140.    --  then release P. A special case of this is when T has no dependents
  141.    --  and is completed. In this case, T itself should be released.
  142.  
  143.    --  If the parent is made passive, this is repeated recursively, with C
  144.    --  being the previous parent and P being the next parent up.
  145.  
  146.    --  Note that we have to hold the locks of both P and C (locked in that
  147.    --  order) so that the Awake_Count of C and the Awaited_Dependent_Count of
  148.    --  P will be synchronized.  Otherwise, an attempt by P to terminate can
  149.    --  preempt this routine after C's Awake_Count has been decremented to zero
  150.    --  but before C has checked the Awaited_Dependent_Count of P.  P would not
  151.    --  count C in its Awaited_Dependent_Count since it is not awake, but it
  152.    --  might count other awake dependents.  When C gained control again, it
  153.    --  would decrement P's Awaited_Dependent_Count to indicate that it is
  154.    --  passive, even though it was never counted as active.  This would cause
  155.    --  P to wake up before all of its dependents are passive.
  156.  
  157.    --  Note : Any task with an interrupt entry should never become passive.
  158.    --  Support for this feature needs to be added here.
  159.  
  160.    procedure Make_Passive (T : Runtime_Types.ATCB_Ptr) is
  161.       P : Runtime_Types.ATCB_Ptr;
  162.       --  Task whose Awaited_Dependent_Count may be decremented.
  163.  
  164.       C : Runtime_Types.ATCB_Ptr;
  165.       --  Task whose awake-count gets decremented.
  166.  
  167.       H : Runtime_Types.ATCB_Ptr;
  168.       --  Highest task that is ready to terminate dependents.
  169.  
  170.       Taken     : Boolean;
  171.       Activator : Runtime_Types.ATCB_Ptr;
  172.  
  173.    begin
  174.       Runtime_Types.Vulnerable_Complete_Activation (T);
  175.  
  176.       Write_Lock (T.L);
  177.  
  178.       if T.Stage >= Runtime_Types.Passive then
  179.          Unlock (T.L);
  180.          return;
  181.       else
  182.          T.Stage := Runtime_Types.Passive;
  183.          Unlock (T.L);
  184.       end if;
  185.  
  186.       H := null;
  187.       P := T.Parent;
  188.       C := T;
  189.  
  190.       while C /= null loop
  191.  
  192.          if P /= null then
  193.             Write_Lock (P.L);
  194.             Write_Lock (C.L);
  195.  
  196.             C.Awake_Count := C.Awake_Count - 1;
  197.  
  198.             if C.Awake_Count /= 0 then
  199.  
  200.                --  C is not passive; we cannot make anything above this point
  201.                --  passive.
  202.  
  203.                Unlock (C.L);
  204.                Unlock (P.L);
  205.                exit;
  206.             end if;
  207.  
  208.             if P.Awaited_Dependent_Count /= 0 then
  209.  
  210.                --  We have hit a non-task master; we will not be able to make
  211.                --  anything above this point passive.
  212.  
  213.                P.Awake_Count := P.Awake_Count - 1;
  214.  
  215.                if C.Mast